unit Charsets;

{*
Conversion between ISO-8859-2, CP1250, CP852, UTF-8
Example: s := CharsetConvert( 'Hello World', CP1250, UTF_8 );
}

interface

uses Windows, SysUtils;

type TMimeChar = (ISO_8859_2, CP1250, CP852, UTF_8); //* Enum for charset type

function CharsetConvert(Value: AnsiString; CharFrom: TMimeChar; CharTo: TMimeChar): AnsiString;

implementation

const
  NotFoundChar = '_';

  CharISO_8859_2: array[128..255] of Word =
  (
    $0080, $0081, $0082, $0083, $0084, $0085, $0086, $0087,
    $0088, $0089, $008A, $008B, $008C, $008D, $008E, $008F,
    $0090, $0091, $0092, $0093, $0094, $0095, $0096, $0097,
    $0098, $0099, $009A, $009B, $009C, $009D, $009E, $009F,
    $00A0, $0104, $02D8, $0141, $00A4, $013D, $015A, $00A7,
    $00A8, $0160, $015E, $0164, $0179, $00AD, $017D, $017B,
    $00B0, $0105, $02DB, $0142, $00B4, $013E, $015B, $02C7,
    $00B8, $0161, $015F, $0165, $017A, $02DD, $017E, $017C,
    $0154, $00C1, $00C2, $0102, $00C4, $0139, $0106, $00C7,
    $010C, $00C9, $0118, $00CB, $011A, $00CD, $00CE, $010E,
    $0110, $0143, $0147, $00D3, $00D4, $0150, $00D6, $00D7,
    $0158, $016E, $00DA, $0170, $00DC, $00DD, $0162, $00DF,
    $0155, $00E1, $00E2, $0103, $00E4, $013A, $0107, $00E7,
    $010D, $00E9, $0119, $00EB, $011B, $00ED, $00EE, $010F,
    $0111, $0144, $0148, $00F3, $00F4, $0151, $00F6, $00F7,
    $0159, $016F, $00FA, $0171, $00FC, $00FD, $0163, $02D9
    );

  CharCP_1250: array[128..255] of Word =
  (
    $20AC, $FFFD, $201A, $FFFD, $201E, $2026, $2020, $2021,
    $FFFD, $2030, $0160, $2039, $015A, $0164, $017D, $0179,
    $FFFD, $2018, $2019, $201C, $201D, $2022, $2013, $2014,
    $FFFD, $2122, $0161, $203A, $015B, $0165, $017E, $017A,
    $00A0, $02C7, $02D8, $0141, $00A4, $0104, $00A6, $00A7,
    $00A8, $00A9, $015E, $00AB, $00AC, $00AD, $00AE, $017B,
    $00B0, $00B1, $02DB, $0142, $00B4, $00B5, $00B6, $00B7,
    $00B8, $0105, $015F, $00BB, $013D, $02DD, $013E, $017C,
    $0154, $00C1, $00C2, $0102, $00C4, $0139, $0106, $00C7,
    $010C, $00C9, $0118, $00CB, $011A, $00CD, $00CE, $010E,
    $0110, $0143, $0147, $00D3, $00D4, $0150, $00D6, $00D7,
    $0158, $016E, $00DA, $0170, $00DC, $00DD, $0162, $00DF,
    $0155, $00E1, $00E2, $0103, $00E4, $013A, $0107, $00E7,
    $010D, $00E9, $0119, $00EB, $011B, $00ED, $00EE, $010F,
    $0111, $0144, $0148, $00F3, $00F4, $0151, $00F6, $00F7,
    $0159, $016F, $00FA, $0171, $00FC, $00FD, $0163, $02D9
    );

  CharCP_852: array[128..255] of Word =
  (
    $00C7, $00FC, $00E9, $00E2, $00E4, $016F, $0107, $00E7,
    $0142, $00EB, $0150, $0151, $00EE, $0179, $00C4, $0106,
    $00C9, $0139, $013A, $00F4, $00F6, $013D, $013E, $015A,
    $015B, $00D6, $00DC, $0164, $0165, $0141, $00D7, $010D,
    $00E1, $00ED, $00F3, $00FA, $0104, $0105, $017D, $017E,
    $0118, $0119, $00AC, $017A, $010C, $015F, $00AB, $00BB,
    $2591, $2592, $2593, $2502, $2524, $00C1, $00C2, $011A,
    $015E, $2563, $2551, $2557, $255D, $017B, $017C, $2510,
    $2514, $2534, $252C, $251C, $2500, $253C, $0102, $0103,
    $255A, $2554, $2569, $2566, $2560, $2550, $256C, $00A4,
    $0111, $0110, $010E, $00CB, $010F, $0147, $00CD, $00CE,
    $011B, $2518, $250C, $2588, $2584, $0162, $016E, $2580,
    $00D3, $00DF, $00D4, $0143, $0144, $0148, $0160, $0161,
    $0154, $00DA, $0155, $0170, $00FD, $00DD, $0163, $00B4,
    $00AD, $02DD, $02DB, $02C7, $02D8, $00A7, $00F7, $00B8,
    $00B0, $00A8, $02D9, $0171, $0158, $0159, $25A0, $00A0
    );

function IntToBin(Value: Integer; Digits: Byte): string;
{*
Konvert decimal number to binary
}
var
  x, y, n: Integer;
begin
  Result := '';
  x := Value;
  repeat
    y := x mod 2;
    x := x div 2;
    if y > 0 then
      Result := '1' + Result
    else
      Result := '0' + Result;
  until x = 0;
  x := Length(Result);
  for n := x to Digits - 1 do
    Result := '0' + Result;
end;

function BinToInt(const Value: string): Integer;
{*
Convert binary number to decimal
}
var
  n: Integer;
begin
  Result := 0;
  for n := 1 to Length(Value) do
  begin
    if Value[n] = '0' then
      Result := Result * 2
    else if Value[n] = '1' then
      Result := Result * 2 + 1
    else
      Break;
  end;
end;

procedure CopyArray(const SourceTable: array of Word;
  var TargetTable: array of Word);
{*
Copy from one field to another
}
var
  n: Integer;
begin
  for n := 0 to 127 do
    TargetTable[n] := SourceTable[n];
end;

procedure GetArray(CharSet: TMimeChar; var Result: array of Word);
{*
Find conversion table for given charset
}
begin
  case CharSet of
    ISO_8859_2: CopyArray(CharISO_8859_2, Result);
    CP1250: CopyArray(CharCP_1250, Result);
    CP852: CopyArray(CharCP_852, Result);
  else
    CopyArray(CharISO_8859_2, Result);
  end;
end;

procedure ReadMulti(const Value: AnsiString; var Index: Integer; mb: Byte; var b1, b2, b3, b4: Byte; le: boolean);
{*
Read characters that are encoded with more than 1 byte
}
begin
  b1 := 0;
  b2 := 0;
  b3 := 0;
  b4 := 0;
  if Index < 0 then
    Index := 1;
  if mb > 4 then
    mb := 1;
  if (Index + mb - 1) <= Length(Value) then
  begin
    if le then
      case mb of
        1:
          b1 := Ord(Value[Index]);
        2:
          begin
            b1 := Ord(Value[Index]);
            b2 := Ord(Value[Index + 1]);
          end;
        3:
          begin
            b1 := Ord(Value[Index]);
            b2 := Ord(Value[Index + 1]);
            b3 := Ord(Value[Index + 2]);
          end;
        4:
          begin
            b1 := Ord(Value[Index]);
            b2 := Ord(Value[Index + 1]);
            b3 := Ord(Value[Index + 2]);
            b4 := Ord(Value[Index + 3]);
          end;
      end
    else
      case mb of
        1:
          b1 := Ord(Value[Index]);
        2:
          begin
            b2 := Ord(Value[Index]);
            b1 := Ord(Value[Index + 1]);
          end;
        3:
          begin
            b3 := Ord(Value[Index]);
            b2 := Ord(Value[Index + 1]);
            b1 := Ord(Value[Index + 2]);
          end;
        4:
          begin
            b4 := Ord(Value[Index]);
            b3 := Ord(Value[Index + 1]);
            b2 := Ord(Value[Index + 2]);
            b1 := Ord(Value[Index + 3]);
          end;
      end;
  end;
  Inc(Index, mb);
end;

function WriteMulti(b1, b2, b3, b4: Byte; mb: Byte; le: boolean): AnsiString;
{*
Write characters represented with more than 1 byte
}
begin
  if mb > 4 then
    mb := 1;
  SetLength(Result, mb);
  if le then
    case mb of
      1:
        Result[1] := AnsiChar(b1);
      2:
        begin
          Result[1] := AnsiChar(b1);
          Result[2] := AnsiChar(b2);
        end;
      3:
        begin
          Result[1] := AnsiChar(b1);
          Result[2] := AnsiChar(b2);
          Result[3] := AnsiChar(b3);
        end;
      4:
        begin
          Result[1] := AnsiChar(b1);
          Result[2] := AnsiChar(b2);
          Result[3] := AnsiChar(b3);
          Result[4] := AnsiChar(b4);
        end;
    end
  else
    case mb of
      1:
        Result[1] := AnsiChar(b1);
      2:
        begin
          Result[2] := AnsiChar(b1);
          Result[1] := AnsiChar(b2);
        end;
      3:
        begin
          Result[3] := AnsiChar(b1);
          Result[2] := AnsiChar(b2);
          Result[1] := AnsiChar(b3);
        end;
      4:
        begin
          Result[4] := AnsiChar(b1);
          Result[3] := AnsiChar(b2);
          Result[2] := AnsiChar(b3);
          Result[1] := AnsiChar(b4);
        end;
    end;
end;

function UTF8toUCS4(const Value: AnsiString): AnsiString;
{*
Convert UTF8 to UCS4
}
var
  n, x, ul, m: Integer;
  s: AnsiString;
  w1, w2: Word;
begin
  Result := '';
  n := 1;
  while Length(Value) >= n do
  begin
    x := Ord(Value[n]);
    Inc(n);
    if x < 128 then
      Result := Result + WriteMulti(x, 0, 0, 0, 4, false)
    else
    begin
      m := 0;
      if (x and $E0) = $C0 then
        m := $1F;
      if (x and $F0) = $E0 then
        m := $0F;
      if (x and $F8) = $F0 then
        m := $07;
      if (x and $FC) = $F8 then
        m := $03;
      if (x and $FE) = $FC then
        m := $01;
      ul := x and m;
      s := IntToBin(ul, 0);
      while Length(Value) >= n do
      begin
        x := Ord(Value[n]);
        Inc(n);
        if (x and $C0) = $80 then
          s := s + IntToBin(x and $3F, 6)
        else
        begin
          Dec(n);
          Break;
        end;
      end;
      ul := BinToInt(s);
      w1 := ul div 65536;
      w2 := ul mod 65536;
      Result := Result + WriteMulti(Lo(w2), Hi(w2), Lo(w1), Hi(w1), 4, false);
    end;
  end;
end;

function UCS4toUTF8(const Value: AnsiString): AnsiString;
{*
Convert UCS4 to UTF8
}
var
  s, l, k: AnsiString;
  b1, b2, b3, b4: Byte;
  n, m, x, y: Integer;
  b: Byte;
begin
  Result := '';
  n := 1;
  while Length(Value) >= n do
  begin
    ReadMulti(Value, n, 4, b1, b2, b3, b4, false);
    if (b2 = 0) and (b3 = 0) and (b4 = 0) and (b1 < 128) then
      Result := Result + AnsiChar(b1)
    else
    begin
      x := (b1 + 256 * b2) + (b3 + 256 * b4) * 65536;
      l := IntToBin(x, 0);
      y := Length(l) div 6;
      s := '';
      for m := 1 to y do
      begin
        k := Copy(l, Length(l) - 5, 6);
        l := Copy(l, 1, Length(l) - 6);
        b := BinToInt(k) or $80;
        s := AnsiChar(b) + s;
      end;
      b := BinToInt(l);
      case y of
        5: b := b or $FC;
        4: b := b or $F8;
        3: b := b or $F0;
        2: b := b or $E0;
        1: b := b or $C0;
      end;
      s := AnsiChar(b) + s;
      Result := Result + s;
    end;
  end;
end;

function InternalToUcs(const Value: AnsiString; Charfrom: TMimeChar): AnsiString;
{*
Convert internal encoding to UCS
}
var
  uni: Word;
  n: Integer;
  b1, b2, b3, b4: Byte;
  SourceTable: array[128..255] of Word;
  mbf: Byte;
  lef: Boolean;
  s: AnsiString;
begin
  if CharFrom = UTF_8 then
    s := UTF8toUCS4(Value)
  else
    s := Value;
  GetArray(CharFrom, SourceTable);
  mbf := 1;
  if CharFrom in [UTF_8] then
    mbf := 4;
  lef := false;
  Result := '';
  n := 1;
  while Length(s) >= n do
  begin
    ReadMulti(s, n, mbf, b1, b2, b3, b4, lef);
    if (b3 = 0) and (b4 = 0) then
    begin
      if (b1 = $FE) and (b2 = $FF) then
      begin
        lef := not lef;
        continue;
      end;
      if (b1 = $FF) and (b2 = $FE) then
        continue;
    end;
    if mbf = 1 then
      if b1 > 127 then
      begin
        uni := SourceTable[b1];
        b1 := Lo(uni);
        b2 := Hi(uni);
      end;
    Result := Result + WriteMulti(b1, b2, b3, b4, 2, False);
  end;
end;

function CharsetConvert(Value: AnsiString; CharFrom: TMimeChar; CharTo:
  TMimeChar): AnsiString;
{*
Convert string from given charset to another charset
Errors: None
See also: AnsiToUtf8, Utf8ToAnsi
}
var
  uni: Word;
  n, m: Integer;
  b: Byte;
  b1, b2, b3, b4: Byte;
  TargetTable: array[128..255] of Word;
  mbt: Byte;
  let: Boolean;
  ucsstring, s, t: AnsiString;
  cd: pointer;
  f: Boolean;
  FromID, ToID: string;
begin
  if (CharFrom = CharTo) then
  begin
    Result := Value;
    Exit;
  end;
  FromID := '';
  ToID := '';
  cd := pointer(-1);
  ucsstring := InternalToUcs(Value, CharFrom);
  GetArray(CharTo, TargetTable);
  mbt := 1;
  if CharTo in [UTF_8] then
    mbt := 4;
  let := false;
  b3 := 0;
  b4 := 0;
  Result := '';
  for n := 0 to (Length(ucsstring) div 2) - 1 do
  begin
    s := Copy(ucsstring, n * 2 + 1, 2);
    b2 := Ord(s[1]);
    b1 := Ord(s[2]);
    uni := b2 * 256 + b1;
    if cd <> pointer(-1) then
    begin
      t := '';
      Result := Result + t;
    end
    else
    begin
      f := True;
      if mbt = 1 then
        if uni > 127 then
        begin
          f := False;
          b := 0;
          for m := 128 to 255 do
            if TargetTable[m] = uni then
            begin
              b := m;
              f := True;
              Break;
            end;
          b1 := b;
          b2 := 0;
        end
        else
          b1 := Lo(uni);
      if f then
        Result := Result + WriteMulti(b1, b2, b3, b4, mbt, let)
    end;
  end;
  if cd = pointer(-1) then
  begin
    if CharTo = UTF_8 then
      Result := UCS4toUTF8(Result);
  end;
end;

end.

